home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / interpret.em < prev    next >
Lisp/Scheme  |  1993-02-02  |  6KB  |  204 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: interpret.em
  4. ;; Date: Sun Jan  5 15:10:54 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;  Simple pseudocode for bytecode interpreter
  9. ;;
  10.  
  11. (defmodule interpret
  12.   (standard0
  13.    list-fns
  14.          
  15.    )
  16.   ()
  17.  
  18.   (defcondition Interpreter-Error ())
  19.  
  20.   ;; A bytevector function 
  21.   (defstruct bv-function ()
  22.     ((bytevector initarg bv reader bv-function-code)
  23.      (env initarg env reader bv-function-env))
  24.     constructor (make-bv-function bv env)
  25.     predicate bv-fn-p)
  26.  
  27.  (defun push (x y) (cons y x))
  28.  
  29.  (defstruct state ()
  30.    ((bytestream initarg bs
  31.         reader state-bs)
  32.     (stack initarg stack 
  33.        reader state-stack))
  34.    constructor make-state)
  35.  
  36.  (defstruct address ()
  37.    ((bv initarg bv 
  38.     reader addr-bv)
  39.     (loc initarg loc 
  40.      accessor addr-loc))
  41.    constructor (make-address bv))
  42.  
  43.  (defun update-state (oldstate fn)
  44.    (make-state 'bs (cdr (state-bs oldstate))
  45.            'stack (fn (state-stack oldstate))))
  46.  
  47.   (defun call-function (state)
  48.     (let ((fn (car (state-stack state))))
  49.       (cond ((bv-fn-p fn)
  50.          (make-state 'bs (bv-function-code fn)
  51.              'stack (if (not (null (bv-function-env fn)))
  52.                     (push (cdr (state-stack state) (bv-function-env fn)))
  53.                   (state-stack state))))
  54.         (t (format t "Unkown function type: ~a~%" 
  55.                Interpreter-Error 
  56.                'error-value fn)))))
  57.  
  58.  (defun do-return (state)
  59.    (let ((stack (state-stack state)))
  60.      (let ((rval (car stack))
  61.        (lab (cadr stack))
  62.        (addr (caddr stack)))
  63.        (if (eq lab 'label)
  64.        (make-state 'bs (addr-bv addr)
  65.                'stack (push (cdddr stack) rval))
  66.      (error "Unbalanced return")))))
  67.                          
  68.  
  69.  (defun interpret (state)
  70.    (format t "Interpret: ~a ~a~%" (car (state-bs state)) (state-stack state))
  71.    (let ((bytestream (state-bs state))
  72.      (update-state (lambda (x) (update-state state x))))
  73.      (cond ((eq (caar bytestream) 'push-static)
  74.         (interpret (update-state
  75.             (lambda (stack)
  76.               (push stack (cadar bytestream))))))
  77.        ((eq (caar bytestream) 'pop-value)
  78.         (interpret (update-state cdr)))
  79.        ((eq (caar bytestream) 'call-function)
  80.         (interpret (call-function bytestream stack)))
  81.        ((eq (caar bytestream) 'stack-ref)
  82.         (interpret (update-state (lambda (stack)
  83.                        (push (nth (cdr stack)
  84.                           (intval (car stack))))))))
  85.        ((eq (caar bytestream) 'env-ref)
  86.         (interpret (update-state (lambda (stack)
  87.                        (push (cdddr stack)
  88.                          (do-env-ref (caddr stack)
  89.                              (cadr stack)
  90.                              (car stack)))))))
  91.        ;; Hacks
  92.        ((eq (caar bytestream) 'push-ret-addr)
  93.         (interpret (update-state (lambda (stack)
  94.                        (push (push stack (cdar bytestream)) 'label)))))
  95.         ((eq (caar bytestream) 'return)
  96.         (interpret (do-return state)))
  97.        ((eq (caar bytestream) 'jump)
  98.         (interpret (make-state 'bs (addr-bv (cdar bytestream))
  99.                    'stack (state-stack state))))
  100.        ((eq (caar bytestream) 'jump-eq)
  101.         (let ((stack (state-stack state))
  102.           (bs (state-bs state)))
  103.           (interpret (make-state 'bs (if (eq (car stack) (cadr stack))
  104.                          (addr-bv (cdar bytestream))
  105.                        (cdr bytestream))
  106.                      'stack (cddr stack)))))
  107.        ((eq (caar bytestream) 'exit)
  108.         (state-stack state))
  109.        ;; primitive functions
  110.        ((eq (caar bytestream) 'alloc-vect)
  111.         (interpret (cdr bytestream)
  112.                (update-state 
  113.             (lambda (stack)
  114.               (push (cdr stack)
  115.                 (make-vector (car stack)))))))
  116.        ((eq (caar bytestream) 'slot-ref)
  117.         (interpret (update-state 
  118.             (lambda (stack)
  119.               (push (caddr stack)
  120.                 (vector-ref (car stack) (cadr stack)))))))
  121.        ((eq (caar bytestream) 'cons)
  122.         (format t "Cons...~%")
  123.         (interpret (update-state
  124.             (lambda (stack)
  125.               (push (cddr stack)
  126.                 (cons (cadr stack) (car stack)))))))
  127.        ((eq (caar bytestream) 'car)
  128.         (interpret (update-state 
  129.             (lambda (stack)
  130.               (push (cdr stack)
  131.                 (car (car stack)))))))
  132.        ((eq (caar bytestream) 'cdr)
  133.         (interpret (update-state
  134.             (lambda (stack)
  135.               (push (cdr stack)
  136.                 (cdr (car stack)))))))
  137.        ((eq (caar bytestream) 'mk-bv-func)
  138.         (interpret (update-state 
  139.             (lambda (stack)
  140.               (push (cddr stack)
  141.                 (make-bv-function (car stack);; env
  142.                           (cadr stack)))))))
  143.        (t (format t "Could not find: ~a~%" (caar bytestream)))
  144.        )))
  145.  
  146.  ;; Worlds simplest linker...
  147.  
  148.  (defun link-bv (bv)
  149.    (link-aux bv nil nil))
  150.  
  151.  (defun link-aux (bv labs jumps)
  152.    (format t "Link: ~a ~a ~a~%" bv labs jumps)
  153.    (cond ((null bv)
  154.       nil)
  155.      ((eq (caar bv) 'label)
  156.       (let ((label (car bv)))
  157.         ((setter car) bv (car (cdr bv)))
  158.         ((setter cdr) bv (cdr (cdr bv)))
  159.         (link-aux bv
  160.               (cons (cons (cadr label) (make-address bv))
  161.                 labs)
  162.               (resolve-lab (cadr label) jumps (make-address bv)))))
  163.      ((or (eq (caar bv) 'jump)
  164.           (eq (caar bv) 'push-ret-addr)
  165.           (eq (caar bv) 'jump-eq))
  166.       (let ((xx (find-label labs (cadar bv))))
  167.         (if (null xx)
  168.         (link-aux (cdr bv) labs (cons (car bv) jumps))
  169.           (progn ((setter cdr) (car bv)  (cdr xx))
  170.              (link-aux (cdr bv) labs jumps)))))
  171.      (t (link-aux (cdr bv) labs jumps))))
  172.  
  173.  (defun resolve-lab (label jumps to)
  174.    (if (null jumps) nil
  175.      (let ((jump (car jumps)))
  176.        (cond ((eq label (cadr jump))
  177.           ((setter cdr) jump to)
  178.           (resolve-lab label (cdr jumps) to))
  179.          (t (cons jump 
  180.               (resolve-lab label (cdr jumps) to)))))))
  181.  
  182.  (defun find-label (labs name)
  183.    (assoc name labs eq))
  184.  
  185.  ;; starter
  186.  (defun ib (bv)
  187.    (interpret (make-state 'bs bv 'stack ())))
  188.  
  189.  ;; Test data
  190.  (deflocal test '((push-static 1) (push-static 2) (cons) (exit)))
  191.  
  192.  (deflocal test-fun '((push-ret-addr lab1)
  193.               (push-static 2)
  194.               (push-static 1)
  195.               (jump lab2)
  196.               (label lab1)
  197.               (exit)
  198.               (label lab2)  ;; Define cons function
  199.               (cons)
  200.               (return)
  201.               ))
  202.   ;; end module
  203.  )
  204.